home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue64 / Alfresco / AAHpDeFr.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-10-22  |  4.5 KB  |  166 lines
  1. {*********************************************************}
  2. {* AAHpDeFr                                              *}
  3. {* Copyright (c) Julian M Bucknall 2000                  *}
  4. {* All rights reserved.                                  *}
  5. {*********************************************************}
  6. {* Algorithms Alfresco: Defragmenting heap               *}
  7. {*********************************************************}
  8.  
  9. {Note: this unit is released as freeware. In other words, you are free
  10.        to use this unit in your own applications, however I retain all
  11.        copyright to the code. JMB}
  12.  
  13. unit AAHpDeFr;
  14.  
  15. {WARNING: this unit *must* appear first in your project's uses list.}
  16.  
  17. interface
  18.  
  19. implementation
  20.  
  21. uses
  22.   Windows; // it's OK to use the Windows unit: it allocates no memory
  23.  
  24. type
  25.   PFreeNode = ^TFreeNode;
  26.   TFreeNode = packed record
  27.     fnNext : PFreeNode;
  28.   end;
  29.  
  30. const
  31.   MinFreeInx = 0;
  32.   MaxFreeInx = (4096 div 32) - 1;
  33.  
  34. var
  35.   OrigHeap : TMemoryManager;
  36.   OurHeap  : TMemoryManager;
  37.  
  38.   {the free lists for blocks of size 32 to 4096}
  39.   FreeList : array [MinFreeInx..MaxFreeInx] of pointer;
  40.  
  41. function OurGetMem(Size : integer) : pointer;
  42. var
  43.   Inx : integer;
  44. begin
  45.   {make a decision based on the size: if it's less than or equal to
  46.    4096 we can get the allocation from our free lists...}
  47.   if (Size <= 4096) then begin
  48.     {round up to the nearest 32 bytes}
  49.     Size := (Size + 31) and not integer(31);
  50.     {if there is a node free on the relevant free list, use it}
  51.     Inx := pred(Size div 32);
  52.     if (FreeList[Inx] <> nil) then begin
  53.       Result := FreeList[Inx];
  54.       FreeList[Inx] := PFreeNode(Result)^.fnNext;
  55.     end
  56.     {otherwise allocate from Delphi's heap manager}
  57.     else
  58.       Result := OrigHeap.GetMem(Size);
  59.   end
  60.   {otherwise the size is too great for our linked lists, round up to
  61.    nearest 1KB and then allocate it from Delphi's heap manager}
  62.   else begin
  63.     Size := (Size + 1023) and not integer(1023);
  64.     Result := OrigHeap.GetMem(Size);
  65.   end;
  66. end;
  67.  
  68. function OurFreeMem(P : pointer) : integer;
  69. type
  70.   PInteger = ^integer;
  71. var
  72.   Size : integer;
  73.   Inx  : integer;
  74. begin
  75.   {make a decision based on the block's size: if it's less than or
  76.    equal to 4096 we can store it on our free lists...}
  77.   Size := PInteger(PChar(P) - sizeof(integer))^ - sizeof(integer);
  78.   if (Size <= 4096) then begin
  79.     Inx := pred(Size div 32);
  80.     PFreeNode(P)^.fnNext := FreeList[Inx];
  81.     FreeList[Inx] := PFreeNode(P);
  82.     Result := 0; {no error}
  83.   end
  84.   {otherwise just free it with the original heap manager}
  85.   else
  86.     Result := OrigHeap.FreeMem(P);
  87. end;
  88.  
  89. function OurReallocMem(P : pointer; Size : integer) : pointer;
  90. var
  91.   OldSize : integer;
  92. begin
  93.   {Realloc is complicated: we need to trap reallocations using our
  94.    free lists. Realloc can be called with 4 possibilities:
  95.      P = nil, Size = 0: return nil
  96.      P = nil, Size > 0: equivalent to GetMem(Size), return new block
  97.      P <> nil, Size = 0: equivalent to FreeMem(Size), return nil
  98.      P <> nil, Size > 0: equivalent to GetMem(Size), copy old data to
  99.                          new block, FreeMem(P), return new block}
  100.   if (P = nil) then begin
  101.     if (Size <> 0) then
  102.       Result := OurGetMem(Size)
  103.     else
  104.       Result := nil;
  105.   end
  106.   else begin
  107.     if (Size = 0) then begin
  108.       OurFreeMem(P);
  109.       Result := nil;
  110.     end
  111.     else begin
  112.       Result := OurGetMem(Size);
  113.       OldSize := PInteger(PChar(P) - sizeof(integer))^ - sizeof(integer);
  114.       if (OldSize <= Size) then
  115.         Move(P^, Result^, OldSize)
  116.       else
  117.         Move(P^, Result^, Size);
  118.       OurFreeMem(P);
  119.     end;
  120.   end;
  121. end;
  122.  
  123. procedure InitializeUnit;
  124. begin
  125.   {initialize the freelists}
  126.   FillChar(FreeList, sizeof(FreeList), 0);
  127.  
  128.   {get the original manager}
  129.   GetMemoryManager(OrigHeap);
  130.  
  131.   {set up our heap manager}
  132.   OurHeap.GetMem := OurGetMem;
  133.   OurHeap.FreeMem := OurFreeMem;
  134.   OurHeap.ReallocMem := OurReallocMem;
  135.  
  136.   {replace heap manager with ours}
  137.   SetMemoryManager(OurHeap);
  138. end;
  139.  
  140. procedure FinalizeUnit;
  141. var
  142.   i    : integer;
  143.   P    : PFreeNode;
  144.   Temp : PFreeNode;
  145. begin
  146.   {free all blocks on the free lists}
  147.   for i := MinFreeInx to MaxFreeInx do begin
  148.     P := FreeList[i];
  149.     while (P <> nil) do begin
  150.       Temp := P;
  151.       P := P^.fnNext;
  152.       OrigHeap.FreeMem(Temp);
  153.     end;
  154.   end;
  155.   {restore the original manager}
  156.   SetMemoryManager(OrigHeap);
  157. end;
  158.  
  159. initialization
  160.   InitializeUnit;
  161.  
  162. finalization
  163.   FinalizeUnit;
  164.  
  165. end.
  166.